{-# LANGUAGE TemplateHaskell, RelaxedPolyRec #-}
-- RelaxedPolyRec is needed because
-- TemplateHaskell is only run after the polymorphic recursion is checked.
-- I'd say this is a bug

module Session.Security(encryptSession, decryptSession) where

import qualified Codec.Binary.UTF8.Generic as UTF8 (toString, fromString)
import Control.Applicative.Error (maybeRead)
import qualified Data.ByteString.Base64 as Base64 (decode, encode)
import Web.ClientSession(encrypt, decrypt, embedDefaultKey)
import Data.ByteString (ByteString)
import Control.Monad((<=<))
import Codec.Binary.UTF8.Generic (UTF8Bytes)

-- This module uses notions of "Bijection" and "Injection" to describe
-- bidirectional data processing in a convenient and less error-prone way.

-- | Represents a two-way transformation.
-- (Bijection f1 f2) should satisfy the property f2.f1 == f1.f2 == id
data Bijection a b = Bijection (a-> b) (b-> a)
-- | Represents a reversible transformation from 'a' to 'b'.
-- (Injection f1 f2) should satisfy the property f2.f1 == Just.
data Injection a b = Injection {forward :: (a-> b), backward :: (b-> Maybe a)}

-- | Composition of injections. Should be used like '.'
(-<-) :: Injection b c -> Injection a b -> Injection a c
(Injection f2 g2) -<- (Injection f1 g1) = Injection (f2 . f1) (g1 <=< g2)

-- | Inverse bijection
inverse :: Bijection a b -> Bijection b a
inverse (Bijection aToB bToA) = (Bijection bToA aToB)

-- | Reduces a bijection to injection
bijToInj (Bijection aToB bToA) = Injection aToB (return.bToA)

-- | Promotes an endomorphic injection from the domain 'a'
-- into the domain 'b' using the specified bijection
mapDomain :: Bijection a b -> Injection a a -> Injection b b
mapDomain bij f =
    let
        abInj = bijToInj bij
        baInj = bijToInj (inverse bij)
    in
        abInj -<- f -<- baInj

-- | A bijection between Strings and byte sequences representing a UTF8
-- encoding. Hides errors if the reverse transformation encounters an
-- invalid byte sequence.
utf8 :: UTF8Bytes b s => Bijection String b
utf8 = Bijection UTF8.fromString UTF8.toString

-- | An injection on ByteStrings representing the Base64 encoding.
-- Reverse transformation is very conservative (sensitive to errors).
base64 :: Injection ByteString ByteString
base64 = Injection Base64.encode (suppress . Base64.decode)
    where
        suppress (Right val) = Just val
        suppress (Left _err) = Nothing

-- | An injection between an object and its String representation,
-- using its Show and Read instances
showage :: (Show a, Read a) => Injection a String
showage = Injection show maybeRead

-- | An injection representing the encryption and decryption
-- with the given key.
encryption :: ByteString -> Injection ByteString ByteString
encryption key = Injection (encrypt key) (decrypt key)

-- | A bidirectional transformation between an object
-- and a value of a corresponding secure cookie.
toSecureCookie :: (Read s, Show s) => Injection s String
toSecureCookie =
        strEncryption -<- showage
    where
        strEncryption = mapDomain (inverse utf8) (base64 -<- encryption serverKey)

-- TODO: remove base64Encoding as the encryption base64-encodes already.
-- I leave it for now for illustration.

-- | Encrypts the session
encryptSession :: (Read s, Show s) => s -> String
encryptSession = forward toSecureCookie

-- | Decrypts the session
decryptSession :: (Read s, Show s) => String -> Maybe s
decryptSession = backward toSecureCookie

-- | The server key.
-- It is embedded in compile-time for performance and runtime purity
serverKey :: ByteString
serverKey = $(embedDefaultKey)
